home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Utilities / Miscellaneous / CopyPaste 3.3.4 / CopyPaste Tools Sourcecode / URLExtractor / URLExtractor.p < prev    next >
Encoding:
Text File  |  1997-06-06  |  3.6 KB  |  141 lines  |  [TEXT/CWIE]
  1. {•This sourcecode is an example for creating a FKey coderesource with•}
  2. {•Metrowerks Pascal. It is copyrighted by Peter Hoerster and released•}
  3. {•for free use in any Shareware or Freeware product as a way to thank all•}
  4. {•programmers who share code snippets. You may put this sources on any•}
  5. {•CD ROM or any Archive Server but you may not sell it. •}
  6.  
  7. {• For comments please write to <hoerster@muenster.de>•}
  8.  
  9.  
  10.  
  11.  
  12. unit EdressExtractor;
  13. interface
  14.  
  15.     uses
  16.         Types, OSUtils, GestaltEqu, Script, notification, Resources, Events,PascalA4,
  17.           QuickDraw, ToolUtils, Memory, LowMem, Scrap; 
  18.  
  19. {$MAIN}
  20.                         
  21.     procedure main;        
  22.  
  23. implementation
  24.  
  25.     const
  26.         step = 1000;
  27.         semikolon = ';';
  28.         komma = ',';
  29.         colon = ':';
  30.         space = ' ';
  31.         openbracket = '<';
  32.         closebracket = '>';
  33.         tab = char(ord(9));
  34.         esc = char(ord(27));
  35.         Enter = char(ord(3));                                {the enter character}
  36.         Return = char(ord(13));                                {the return character}
  37.  
  38.  
  39. procedure Fillthearray(myclipHandle: handle;resulthdl:handle; myclipsize: longint);
  40.     type
  41.             chararray=packed array[1..1]of char;
  42.             charptr=^chararray;
  43.             charhdl=^charptr;
  44.         var
  45.             charcount, startposition: longint;
  46.             count: longint;
  47.             readbuffer: str63;
  48.             myerr:oserr;
  49.             done, found: boolean;
  50.     begin
  51.         readbuffer := 'o';
  52.         done := false;
  53.         startposition := 0;
  54.         count := 0;
  55.         repeat
  56.             count := count+1;
  57.             if count>myclipsize then
  58.                 done:=true
  59.             else
  60.                 begin
  61.                     //readbuffer[1]:=charhdl(myclipHandle)^^[count];
  62.                     if (ord(char(charhdl(myclipHandle)^^[count]))<45)|
  63.                     ((ord(char(charhdl(myclipHandle)^^[count]))>58) & (ord(char(charhdl(myclipHandle)^^[count]))<64)) then
  64.                     
  65.                          startposition:=count;
  66.                     if (charhdl(myclipHandle)^^[count] = '/')then
  67.                         if count>7 then
  68.                             if ((charhdl(myclipHandle)^^[count+1] = '/')&(charhdl(myclipHandle)^^[count-1] = ':'))then
  69.                     
  70.                         begin
  71.                             count:= startposition;
  72.                             found := false;
  73.                             charcount := 0;
  74.                             repeat
  75.                                 charcount := charcount + 1;
  76.                                 count:=count+1;
  77.                                 
  78.                                 {if (readbuffer[1] in [space, tab, enter, return,
  79.                                 openbracket, closebracket, semikolon, komma, colon]) then}
  80.                                 if (ord(char(charhdl(myclipHandle)^^[count]))<45)|
  81.                                 ((ord(char(charhdl(myclipHandle)^^[count]))>58) & (ord(char(charhdl(myclipHandle)^^[count]))<64)) then
  82.                                     found := true
  83.                             until found | (charcount > 50);
  84.                             if found=true then
  85.                                 begin
  86.                                     readbuffer[0]:=char(ord(charcount));
  87.                                     blockmove( pointer(ord4(myclipHandle^)+startposition),@readbuffer[1],charcount-1);
  88.                                     readbuffer[charcount] := return;
  89.                                     if pos('.',readbuffer)>0 then
  90.                                         myerr:=PtrAndHand(@readbuffer[1],resulthdl,charcount);
  91.                                     readbuffer := 'o';
  92.                                 end;
  93.                             startposition:=count;
  94.                         end;
  95.                 end;
  96.         until (done);
  97.     end;
  98.  
  99. procedure dopaste;
  100.     const
  101.         pastecode=2422;
  102.     var 
  103.         qel: EvQelPtr;
  104.     begin
  105.             if ppostevent(3, pastecode, qel) = noerr then
  106.             qel^.evtqmodifiers := cmdkey;
  107.     end;
  108.  
  109.  
  110.     procedure main;
  111.         var
  112.             oldA4: LongInt;
  113.             myerr:oserr;
  114.             myclipsize,templongint: longint;
  115.             myclipHandle: handle;
  116.             resulthdl:handle;
  117.     begin
  118.         oldA4 := SetCurrentA4;
  119.         myclipsize := GetScrap(nil, 'TEXT', templongint);
  120.         resulthdl:=newhandlesys(0);
  121.         mycliphandle := Tempnewhandle(myclipsize,myerr);
  122.         
  123.         if memerror=noerr then 
  124.             begin
  125.                 myclipsize := GetScraP(myclipHandle, 'TEXT', templongint);
  126.                 if myclipsize > 0 then
  127.                     begin
  128.                         Fillthearray(myclipHandle,resulthdl,myclipsize);
  129.                         hlock(resulthdl);
  130.                         myerr := ZeroScrap;
  131.                         myerr := putscrap(gethandlesize(resulthdl), 'TEXT', resulthdl^);
  132.                         hunlock(resulthdl);
  133.                         dopaste;
  134.                     end;
  135.             end;
  136.         TempDisposeHandle(myCliphandle,myerr);
  137.         oldA4 := SetA4(oldA4);
  138.     end;
  139. end.
  140.  
  141.